home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / internet.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  10.5 KB  |  363 lines
  1. ;;; -*- Log: code.log; Package: extensions -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: internet.lisp,v 1.11 92/07/15 11:43:13 garland Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains an interface to internet domain sockets.
  15. ;;;
  16. ;;; Written by William Lott.
  17. ;;;
  18.  
  19. (in-package "EXTENSIONS")
  20.  
  21. (use-package "ALIEN")
  22. (use-package "C-CALL")
  23.  
  24. (export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name
  25.       host-entry-aliases host-entry-addr-list host-entry-addr
  26.       create-unix-socket connect-to-unix-socket create-inet-socket
  27.       connect-to-inet-socket create-inet-listener accept-tcp-connection
  28.       close-socket ipproto-tcp ipproto-udp inaddr-any add-oob-handler
  29.       remove-oob-handler remove-all-oob-handlers
  30.       send-character-out-of-band))
  31.  
  32.  
  33. (defconstant sock-stream 1)
  34. (defconstant sock-dgram 2)
  35. (defconstant sock-raw 3)
  36.  
  37. (defconstant af-unix 1)
  38. (defconstant af-inet 2)
  39.  
  40. (defconstant msg-oob 1)
  41. (defconstant msg-peek 2)
  42. (defconstant msg-dontroute 4)
  43.  
  44. (defvar *internet-protocols*
  45.   (list (list :stream 6 sock-stream)
  46.     (list :data-gram 17 sock-dgram))
  47.   "AList of socket kinds and protocol values.")
  48.  
  49. (defun internet-protocol (kind)
  50.   (let ((entry (assoc kind *internet-protocols*)))
  51.     (unless entry
  52.       (error "Invalid kind (~S) for internet domain sockets." kind))
  53.     (values (cadr entry)
  54.         (caddr entry))))
  55.  
  56.  
  57. (defmacro maybe-byte-swap (var bytes)
  58.   (ecase (c:backend-byte-order c:*backend*)
  59.     (:big-endian
  60.      var)
  61.     (:little-endian
  62.      (let ((ldbs nil))
  63.        (dotimes (i bytes `(logior ,@ldbs))
  64.      (push `(ash (ldb (byte 8 ,(* i 8)) ,var)
  65.              ,(* (- bytes 1 i) 8))
  66.            ldbs))))))
  67.  
  68. (proclaim '(inline htonl ntohl htons ntohs))
  69.  
  70. (defun htonl (x)
  71.   (maybe-byte-swap x 4))
  72. (defun ntohl (x)
  73.   (maybe-byte-swap x 4))
  74. (defun htons (x)
  75.   (maybe-byte-swap x 2))
  76. (defun ntohs (x)
  77.   (maybe-byte-swap x 2))
  78.  
  79.  
  80. ;;;; Host entry operations.
  81.  
  82. (defstruct host-entry
  83.   name
  84.   aliases
  85.   addr-type
  86.   addr-list)
  87.  
  88. (defun host-entry-addr (host)
  89.   (declare (type host-entry host))
  90.   (car (host-entry-addr-list host)))
  91.  
  92. (def-alien-type unix-sockaddr
  93.   (struct nil
  94.     (family short)
  95.     (path (array char 108))))
  96.  
  97. (def-alien-type inet-sockaddr
  98.   (struct nil
  99.     (family short)
  100.     (port unsigned-short)
  101.     (addr unsigned-long)
  102.     (zero (array char 8))))
  103.  
  104. (def-alien-type hostent
  105.   (struct nil
  106.     (name c-string)
  107.     (aliases (* c-string))
  108.     (addrtype int)
  109.     (length int)
  110.     (addr-list (* (* (unsigned 32))))))
  111.  
  112. (def-alien-routine "gethostbyname" (* hostent)
  113.   (name c-string))
  114.  
  115. (def-alien-routine "gethostbyaddr" (* hostent)
  116.   (addr unsigned-long :copy)
  117.   (len int)
  118.   (type int))
  119.  
  120. (defun lookup-host-entry (host)
  121.   (if (typep host 'host-entry)
  122.       host
  123.       (with-alien
  124.       ((hostent (* hostent) 
  125.             (etypecase host
  126.               (string
  127.                (gethostbyname host))
  128.               ((unsigned-byte 32)
  129.                (gethostbyaddr host 4 af-inet)))))
  130.     (unless (zerop (sap-int (alien-sap hostent)))
  131.       (make-host-entry
  132.        :name (slot hostent 'name)
  133.        :aliases
  134.        (loop
  135.          for index upfrom 0
  136.          while (not (zerop (deref (cast (slot hostent 'aliases)
  137.                         (* (unsigned 32)))
  138.                       index)))
  139.          collect (deref (slot hostent 'aliases) index))
  140.        :addr-type (slot hostent 'addrtype)
  141.        :addr-list
  142.        (loop
  143.          for index upfrom 0
  144.          while (not (zerop (deref (cast (slot hostent 'addr-list)
  145.                         (* (unsigned 32)))
  146.                       index)))
  147.          collect (deref (deref (slot hostent 'addr-list) index))))))))
  148.  
  149. (defun create-unix-socket (&optional (kind :stream))
  150.   (multiple-value-bind (proto type)
  151.                (internet-protocol kind)
  152.     (declare (ignore proto))
  153.     (let ((socket (unix:unix-socket af-unix type 0)))
  154.       (when (minusp socket)
  155.     (error "Error creating socket: ~A" (unix:get-unix-error-msg)))
  156.       socket)))
  157.  
  158. (defun connect-to-unix-socket (path &optional (kind :stream))
  159.   (declare (simple-string path))
  160.   (let ((socket (create-unix-socket kind)))
  161.     (with-alien ((sockaddr unix-sockaddr))
  162.       (setf (slot sockaddr 'family) af-unix)
  163.       (kernel:copy-to-system-area path
  164.                   (* vm:vector-data-offset vm:word-bits)
  165.                   (alien-sap (slot sockaddr 'path))
  166.                   0
  167.                   (* (1+ (length path)) vm:byte-bits))
  168.       (when (minusp (unix:unix-connect socket
  169.                        (alien-sap sockaddr)
  170.                        (alien-size unix-sockaddr :bytes)))
  171.     (unix:unix-close socket)
  172.     (error "Error connecting socket to [~A]: ~A"
  173.            path (unix:get-unix-error-msg)))
  174.       socket)))
  175.  
  176. (defun create-inet-socket (&optional (kind :stream))
  177.   (multiple-value-bind (proto type)
  178.                (internet-protocol kind)
  179.     (let ((socket (unix:unix-socket af-inet type proto)))
  180.       (when (minusp socket)
  181.     (error "Error creating socket: ~A" (unix:get-unix-error-msg)))
  182.       socket)))
  183.  
  184. (defun connect-to-inet-socket (host port &optional (kind :stream))
  185.   (let ((socket (create-inet-socket kind))
  186.     (hostent (or (lookup-host-entry host)
  187.              (error "Unknown host: ~S." host))))
  188.     (with-alien ((sockaddr inet-sockaddr))
  189.       (setf (slot sockaddr 'family) af-inet)
  190.       (setf (slot sockaddr 'port) (htons port))
  191.       (setf (slot sockaddr 'addr) (host-entry-addr hostent))
  192.       (when (minusp (unix:unix-connect socket
  193.                        (alien-sap sockaddr)
  194.                        (alien-size inet-sockaddr :bytes)))
  195.     (unix:unix-close socket)
  196.     (error "Error connecting socket to [~A:~A]: ~A"
  197.            (host-entry-name hostent)
  198.            port
  199.            (unix:get-unix-error-msg)))
  200.       socket)))
  201.  
  202. (defun create-inet-listener (port &optional (kind :stream))
  203.   (let ((socket (create-inet-socket kind)))
  204.     (with-alien ((sockaddr inet-sockaddr))
  205.       (setf (slot sockaddr 'family) af-inet)
  206.       (setf (slot sockaddr 'port) (htons port))
  207.       (setf (slot sockaddr 'addr) 0)
  208.       (when (minusp (unix:unix-bind socket
  209.                     (alien-sap sockaddr)
  210.                     (alien-size inet-sockaddr :bytes)))
  211.     (unix:unix-close socket)
  212.     (error "Error binding socket to port ~a: ~a"
  213.            port
  214.            (unix:get-unix-error-msg))))
  215.     (when (eq kind :stream)
  216.       (when (minusp (unix:unix-listen socket 5))
  217.     (unix:unix-close socket)
  218.     (error "Error listening to socket: ~A" (unix:get-unix-error-msg))))
  219.     socket))
  220.  
  221. (defun accept-tcp-connection (unconnected)
  222.   (declare (fixnum unconnected))
  223.   (with-alien ((sockaddr inet-sockaddr))
  224.     (let ((connected (unix:unix-accept unconnected
  225.                        (alien-sap sockaddr)
  226.                        (alien-size inet-sockaddr :bytes))))
  227.       (when (minusp connected)
  228.     (error "Error accepting a connection: ~A" (unix:get-unix-error-msg)))
  229.       (values connected (slot sockaddr 'addr)))))
  230.  
  231. (defun close-socket (socket)
  232.   (multiple-value-bind (ok err)
  233.                (unix:unix-close socket)
  234.     (unless ok
  235.       (error "Error closing socket: ~A" (unix:get-unix-error-msg err))))
  236.   (undefined-value))
  237.  
  238.  
  239.  
  240. ;;;; Out of Band Data.
  241.  
  242. ;;; Two level AList. First levels key is the file descriptor, second levels
  243. ;;; key is the character. The datum is the handler to call.
  244.  
  245. (defvar *oob-handlers* nil)
  246.  
  247. ;;; SIGURG-HANDLER -- internal
  248. ;;;
  249. ;;;   Routine that gets called whenever out-of-band data shows up. Checks each
  250. ;;; file descriptor for any oob data. If there is any, look for a handler for
  251. ;;; that character. If any are found, funcall them.
  252.  
  253. (defun sigurg-handler (signo code scp)
  254.   (declare (ignore signo code scp))
  255.   (let ((buffer (make-string 1))
  256.     (handled nil))
  257.     (declare (simple-string buffer))
  258.     (dolist (handlers *oob-handlers*)
  259.       (declare (list handlers))
  260.       (cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob))
  261.          (cerror "Ignore it"
  262.              "Error recving oob data on ~A: ~A"
  263.              (car handlers)
  264.              (unix:get-unix-error-msg)))
  265.         (t
  266.          (setf handled t)
  267.          (let ((char (schar buffer 0))
  268.            (handled nil))
  269.            (declare (base-char char))
  270.            (dolist (handler (cdr handlers))
  271.          (declare (list handler))
  272.          (when (eql (car handler) char)
  273.            (funcall (cdr handler))
  274.            (setf handled t)))
  275.            (unless handled
  276.          (cerror "Ignore it"
  277.              "No oob handler defined for ~S on ~A"
  278.              char
  279.              (car handlers)))))))
  280.     (unless handled
  281.       (cerror "Ignore it"
  282.           "Got a SIGURG, but couldn't find any out-of-band data.")))
  283.   (undefined-value))
  284.  
  285. ;;; ADD-OOB-HANDLER -- public
  286. ;;;
  287. ;;;   First, check to see if we already have any handlers for this file
  288. ;;; descriptor. If so, just add this handler to them. If not, add this
  289. ;;; file descriptor to *oob-handlers*, make sure our interupt handler is
  290. ;;; installed, and that the given file descriptor is "owned" by us (so sigurg
  291. ;;; will be delivered.)
  292.  
  293. (defun add-oob-handler (fd char handler)
  294.   "Arange to funcall HANDLER when CHAR shows up out-of-band on FD."
  295.   (declare (integer fd)
  296.        (base-char char))
  297.   (let ((handlers (assoc fd *oob-handlers*)))
  298.     (declare (list handlers))
  299.     (cond (handlers
  300.        (push (cons char handler)
  301.          (cdr handlers)))
  302.       (t
  303.        (push (list fd
  304.                (cons char
  305.                  handler))
  306.          *oob-handlers*)
  307.        (system:enable-interrupt unix:sigurg #'sigurg-handler)
  308.        (unix:unix-fcntl fd unix:f-setown (unix:unix-getpid)))))
  309.   (values))
  310.  
  311. ;;; REMOVE-OOB-HANDLER -- public
  312. ;;;
  313. ;;;   Delete any handlers for the given char from the list of handlers for the
  314. ;;; given file descriptor. If there are no more, nuke the entry for the file
  315. ;;; descriptor.
  316.  
  317. (defun remove-oob-handler (fd char)
  318.   "Remove any handlers for CHAR on FD."
  319.   (declare (integer fd)
  320.        (base-char char))
  321.   (let ((handlers (assoc fd *oob-handlers*)))
  322.     (declare (list handlers))
  323.     (when handlers
  324.       (let ((remaining (delete char handlers
  325.                    :test #'eql
  326.                    :key #'car)))
  327.     (declare (list remaining))
  328.     (if remaining
  329.       (setf (cdr handlers) remaining)
  330.       (setf *oob-handlers*
  331.         (delete fd *oob-handlers*
  332.             :test #'eql
  333.             :key #'car))))))
  334.   (values))
  335.  
  336. ;;; REMOVE-ALL-OOB-HANDLERS -- public
  337. ;;;
  338. ;;;   Delete the entry for the given file descriptor.
  339.  
  340. (defun remove-all-oob-handlers (fd)
  341.   "Remove all handlers for FD."
  342.   (declare (integer fd))
  343.   (setf *oob-handlers*
  344.     (delete fd *oob-handlers*
  345.         :test #'eql
  346.         :key #'car))
  347.   (values))
  348.  
  349. ;;; SEND-CHARACTER-OUT-OF-BAND -- public
  350. ;;;
  351. ;;;   Sends CHAR across FD out of band.
  352.  
  353. (defun send-character-out-of-band (fd char)
  354.   (declare (integer fd)
  355.        (base-char char))
  356.   (let ((buffer (make-string 1 :initial-element char)))
  357.     (declare (simple-string buffer))
  358.     (when (minusp (unix:unix-send fd buffer 1 msg-oob))
  359.       (error "Error sending ~S OOB to across ~A: ~A"
  360.          char
  361.          fd
  362.          (unix:get-unix-error-msg)))))
  363.